home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / ada / vax.ada < prev   
Encoding:
Text File  |  1988-03-25  |  3.5 KB  |  115 lines
  1. -- VAX.ADA   Ver. 1.00   25-MAR-1988
  2. -- Copyright 1988 John J. Herro
  3. -- Software Innovations Technology
  4. -- 1083 Mandarin Drive NE, Palm Bay, FL 32905-4706   (407)951-0233
  5. --
  6. -- Compile this before compiling ADA-TUTR.ADA with Vax Ada (tm, Digital
  7. -- Equipment Corporation).
  8. --
  9. package CON_IO is
  10.    procedure GET      (ITEM : out CHARACTER);
  11.    procedure GET      (ITEM : in out STRING);
  12.    procedure PUT      (ITEM : in CHARACTER);
  13.    procedure PUT      (ITEM : in STRING);
  14.    procedure PUT_LINE (ITEM : in STRING);
  15.    procedure NEW_LINE;
  16.    procedure CLS;  -- Clears the screen.
  17. end CON_IO;
  18.  
  19. with CON_IO; use CON_IO;
  20. procedure QGET(C : out CHARACTER) is
  21. begin
  22.    GET(C);
  23. end QGET;
  24.  
  25. with STARLET, SYSTEM; use STARLET, SYSTEM;
  26. package body CON_IO is
  27.    CHAN : STARLET.CHANNEL_TYPE;
  28.    IOSB : SYSTEM.UNSIGNED_QUADWORD;
  29.    STAT : SYSTEM.UNSIGNED_LONGWORD;
  30.    procedure QIOW(STAT : out UNSIGNED_LONGWORD; EFN : in INTEGER;
  31.         CHAN : in CHANNEL_TYPE; FUNC : in SHORT_INTEGER;
  32.         IOSB : out UNSIGNED_QUADWORD; ASTADR : in INTEGER; ASTPRM : in INTEGER;
  33.         P1 : in out STRING; P2, P3 : in INTEGER; P4 : in UNSIGNED_QUADWORD;
  34.         P5, P6 : in INTEGER);
  35.    pragma INTERFACE(SYSTEM_LIBRARY, QIOW);
  36.    pragma IMPORT_VALUED_PROCEDURE(INTERNAL => QIOW, EXTERNAL => "SYS$QIOW",
  37.         PARAMETER_TYPES => (UNSIGNED_LONGWORD, INTEGER, CHANNEL_TYPE,
  38.              SHORT_INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER, STRING,
  39.              INTEGER, INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER),
  40.         MECHANISM => (VALUE, VALUE, VALUE, VALUE, REFERENCE, VALUE, REFERENCE,
  41.              REFERENCE, VALUE, REFERENCE, REFERENCE, REFERENCE, REFERENCE));
  42.  
  43.    procedure GET(ITEM : out CHARACTER) is
  44.       S : STRING(1 .. 1);
  45.    begin
  46.       QIOW(STAT, 0, CHAN, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
  47.       ITEM := S(1);
  48.    end GET;
  49.  
  50.    procedure PUT(ITEM : in CHARACTER) is
  51.    begin
  52.       PUT(ITEM & "");
  53.    end PUT;
  54.  
  55.    procedure PUT(ITEM : in STRING) is
  56.       S : STRING(ITEM'RANGE) := ITEM;
  57.    begin
  58.       QIOW(STAT, 0, CHAN, 16#70#, IOSB, 0, 0, S, S'LENGTH, 0, (0,0), 0, 0);
  59.    end PUT;
  60.  
  61.    procedure PUT_LINE(ITEM : in STRING) is
  62.    begin
  63.       PUT(ITEM & ASCII.CR & ASCII.LF);
  64.    end PUT_LINE;
  65.  
  66.    procedure NEW_LINE is
  67.    begin
  68.       PUT(ASCII.CR & ASCII.LF);
  69.    end NEW_LINE;
  70.  
  71.    procedure CLS is
  72.    begin
  73.       PUT(ASCII.ESC & "[H" & ASCII.ESC & "[J");
  74.    end CLS;
  75.  
  76.    procedure GET(ITEM : in out STRING) is separate;
  77. begin
  78.    STARLET.ASSIGN(STAT, "TT:", CHAN);
  79. end CON_IO;
  80.  
  81. separate (CON_IO)
  82. procedure GET(ITEM : in out STRING) is
  83.    INPUT : STRING(1 .. ITEM'LENGTH);
  84.    LEN   : NATURAL := 0;
  85.    PLACE : POSITIVE := 1;
  86.    CHAR  : CHARACTER := ' ';
  87. begin
  88.    while CHAR /= ASCII.CR loop
  89.       GET(CHAR);
  90.       if CHAR = ASCII.CR then
  91.          NEW_LINE;
  92.       elsif CHAR = ASCII.DEL then
  93.          if PLACE > 1 then
  94.             PUT(ASCII.BS & INPUT(PLACE .. LEN) & ' ');
  95.             PLACE := PLACE - 1;
  96.             for I in 1 .. LEN + 1 - PLACE loop
  97.                PUT(ASCII.BS);
  98.             end loop;
  99.             LEN := LEN - 1;
  100.             INPUT(PLACE .. LEN) := INPUT(PLACE + 1 .. LEN + 1);
  101.          end if;
  102.       elsif LEN = ITEM'LENGTH and PLACE > ITEM'LENGTH then
  103.          PUT(ASCII.BEL);
  104.       else
  105.          PUT(CHAR);
  106.          INPUT(PLACE) := CHAR;
  107.          if LEN < PLACE then
  108.             LEN := LEN + 1;
  109.          end if;
  110.          PLACE := PLACE + 1;
  111.       end if;
  112.    end loop;
  113.    ITEM(ITEM'FIRST .. ITEM'FIRST + LEN - 1) := INPUT(1 .. LEN);
  114. end GET;
  115.